Delphi Magazine Collection 2001/Delphi Magazine Collection 20001 (2001).iso/DISKS/Issue30/bdeorx/BDEDORX.ZIP/Px7Tbl/PX7TABLE.PAS

Pascal/Delphi Source File | 1997-12-22 | 9.9 KB | 340 lines

unit Px7Table;

(*

***************************************************************
*                                                             *
*  Px7Table compoment                                         *
*                                                             *
*  (c) 1996-97 Reinhard Kalinke                               *
*                                                             *
*  [e-mail]                                   *
*                                                             *
***************************************************************

This is a TTable descendant with an added method to make use of
the new Pdox7 descending indices. With this type of index, you
can determine the sortorder for every single field in the index.
It also adds an event that will be trigerred on certain open errors
like 'index out of date' or files/tables related with the table are
missing. Finally it implements autosaving changes to disk.

*)

interface

uses
  SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
  Forms, Dialogs, DB, DBTables, DBConsts, DBITypes;

type
  TPDXOpenFailType = (ofNone,ofIndexOutOfDate,ofMBMissing,ofLookUpMissing,
                      ofDetailMissing,ofMasterMissing,ofValFileCorrupt);
  TPDXOpenFailure = procedure(Sender: TObject; FailType: TPDXOpenFailType) of object;
  TPx7Table = class(TTable)
  private
    FFailType: TPDXOpenFailType;
    FOnOpenFailure: TPDXOpenFailure;
    FAutoSaveChanges: boolean;
    FAutoChangeLevel: boolean;
    procedure EncodePx7IndexDesc(var IndexDesc: IDXDesc;
      const Name, Fields, DescFields: string;
      Options: TIndexOptions);
    function IsPxTable: Boolean;
    procedure SetAutoSaveChanges(Value: boolean);
    procedure SetAutoChangeLevel(Value: boolean);
  protected
    function CreateHandle: hDBICur; override;
    procedure DoAfterPost; override;
    procedure DoAfterDelete; override;
  public
    constructor Create(AOwner: TComponent); override;
    procedure AddPx7Index(const Name, Fields, DescFields: string;
      Options: TIndexOptions);
    function GetDescFields(const IxName: string): string;
    function GetLevel: string;
    procedure SetLevel(ALevel: string);
  published
    property AutoSaveChanges: boolean
      read FAutoSaveChanges write SetAutoSaveChanges default True;
    property AutoChangeLevel: boolean
      read FAutoChangeLevel write SetAutoChangeLevel default True;
    property OnOpenFailure: TPDXOpenFailure
      read FOnOpenFailure write FOnOpenFailure;
  end;

procedure Register;

implementation

uses DBIProcs, DBIErrs;

constructor TPx7Table.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FAutoSaveChanges := True;
  FAutoChangeLevel := True;
end;

function TPx7Table.CreateHandle: hDBICur;
var BDEError: DBIResult;
    i: integer;
begin
  try try
    Result := inherited CreateHandle;
  except
    on E:EDBEngineError do
    begin
      for i:=0 to pred(E.ErrorCount) do
      begin
        BDEError := E.Errors[i].ErrorCode;
        if (BDEError = DBIERR_INDEXOUTOFDATE) then
          FFailType := ofIndexOutOfDate
        else
        if (BDEError = DBIERR_LOOKUPTBLOPENERR) then
          FFailType := ofLookupMissing
        else
        if (BDEError = DBIERR_DETAILTBLOPENERR) then
          FFailType := ofDetailMissing
        else
        if (BDEError = DBIERR_MASTERTBLOPENERR) then
          FFailType := ofMasterMissing
        else
        if (BDEError = DBIERR_VALFILECORRUPT) then
          FFailType := ofValFileCorrupt
        else
        if (BDEError = DBIERR_BLOBFILEMISSING) then
          FFailType := ofMBMissing;
      end;
      if (FFailType <> ofNone) then
        Sysutils.Abort
      else raise;
    end;{}
  end;
  finally
    if (FFailType <> ofNone)
    and Assigned(FOnOpenFailure) then
      FOnOpenFailure(Self, FFailType);
    FFailType := ofNone;
  end;
end;

procedure TPx7Table.DoAfterPost;
begin
  if FAutoSaveChanges then
    DBISaveChanges(Handle);
  inherited DoAfterPost;
end;

procedure TPx7Table.DoAfterDelete;
begin
  if FAutoSaveChanges then
    DBISaveChanges(Handle);
  inherited DoAfterDelete;
end;

function TPx7Table.GetDescFields(const IxName: string): string;
var IxDesc: IDXDesc;
    IxNo: word;
    szIxStr: DBIName;
    i,j: integer;
begin
  Result := '';
  {$IFNDEF VER100}
  if not Active then DBError(SDataSetClosed);
  {$ELSE}
  if not Active then DataBaseError(SDataSetClosed);
  {$ENDIF}
  StrPCopy(szIxStr, IxName);
  Check( DBIGetIndexSeqNo(Handle, szIxStr, nil, 0, IxNo) );
  Check( DBIGetIndexDesc(Handle, IxNo, IxDesc) );
  with FieldDefs, IxDesc do
  begin
    Update;
    {$IFDEF WIN32}
    for i := 0 to high(abDescending) do
      if abDescending[i] then
    {$ELSE}
    for i := 0 to high(iUnUsed) do
      if (iUnUsed[i] = 1) then
    {$ENDIF}
        for j := 0 to pred(Count) do
          if FieldDefs[j].FieldNo = aiKeyFld[i] then
          begin
            Result := Result + FieldDefs[j].Name + ';';
            Break;
          end;
    if Result > '' then
      {$IFDEF WIN32}
      SetLength(Result,pred(Length(Result)));
      {$ELSE}
      Result[0] := char(pred(Length(Result)));
      {$ENDIF}
  end;
end;

procedure TPx7Table.AddPx7Index(const Name, Fields,
                                DescFields: string;
                                Options: TIndexOptions);
var
  STableName: DBITBLNAME;
  IndexDesc: IDXDesc;
begin
  if (DescFields > '') and (GetLevel < '7') then
  begin
    if FAutoChangeLevel then
      SetLevel('7')
    else
      raise Exception.Create('Table level 7 required');
  end;
  if not IsPxTable then
    AddIndex(Name, Fields, Options) {or raise an exception}
  else
  begin
    FieldDefs.Update;
    EncodePx7IndexDesc(IndexDesc, Name, Fields, DescFields, Options);
    if Active then
    begin
      CheckBrowseMode;
      CursorPosChanged;
      Check(DbiAddIndex(DBHandle, Handle, nil, nil, IndexDesc, nil));
    end else
    begin
      SetDBFlag(dbfTable, True);
      try
        Check(DbiAddIndex(DBHandle, nil, AnsiToNative(DBLocale, TableName,
          STableName, SizeOf(STableName) - 1), szParadox,
          IndexDesc, nil));
      finally
        SetDBFlag(dbfTable, False);
      end;
    end;
    DataEvent(dePropertyChange, 0);
  end;
end;

procedure TPx7Table.EncodePx7IndexDesc(var IndexDesc: IDXDesc;
  const Name, Fields, DescFields: string; Options: TIndexOptions);
var
  iPos, jPos: Integer;
begin
  FillChar(IndexDesc, SizeOf(IndexDesc), 0);
  with IndexDesc do
  begin
    AnsiToNative(DBLocale, Name, szName, SizeOf(szName) - 1);
    bPrimary := ixPrimary in Options;
    bUnique := ixUnique in Options;
    bDescending := ixDescending in Options;
    bCaseInsensitive := ixCaseInsensitive in Options;
    bMaintained := True;
    iPos := 1;
    while (iPos <= Length(Fields)) and (iFldsInKey < 16) do
    begin
      jPos := iPos;
      aiKeyFld[iFldsInKey] :=
        FieldDefs.Find(ExtractFieldName(Fields,iPos)).FieldNo;
      {this is the one that makes a field descending:}
      if bDescending
      and (pos(ExtractFieldName(Fields,jPos),DescFields)<>0) then
        {$IFDEF WIN32}
        abDescending[iFldsInKey] := True;
        {$ELSE}
        iUnUsed[iFldsInKey] := 1;
        {$ENDIF}
      Inc(iFldsInKey);
    end;
  end;
end;

function TPx7Table.IsPxTable: Boolean;
begin
  Result := (TableType = ttParadox) or
    (CompareText(ExtractFileExt(TableName), '.DB') = 0);
end;

function TPx7Table.GetLevel: string;
var TblProps: CURProps;
begin
  {$IFNDEF VER100}
  if not Active then DBError(SDataSetClosed);
  {$ELSE}
  if not Active then DataBaseError(SDataSetClosed);
  {$ENDIF}
  Check(DBIGetCursorProps(Handle,TblProps));
  Result := IntToStr(TblProps.iTblLevel);
end;

procedure TPx7Table.SetLevel(ALevel: string);
var hDB: hDBIdb;
    TblProps: CURProps;
    pTableDesc: pCRTblDesc;
    pOptFldDesc: pFLDDesc;
    szLevel: DBIName;
begin
  {$IFNDEF VER100}
  if not Active then DBError(SDataSetClosed);
  {$ELSE}
  if not Active then DataBaseError(SDataSetClosed);
  {$ENDIF}
  pTableDesc := nil;
  pOptFldDesc := nil;
  Check(DBIGetCursorProps(Handle,TblProps));
  if (TblProps.iTblLevel <> StrToInt(ALevel)) then
  try
    DisableControls;
    GetMem(pTableDesc,sizeOf(CRTblDesc));
    FillChar(pTableDesc^,sizeOf(CRTblDesc),0);
    GetMem(pOptFldDesc,sizeOf(FLDDesc));
    FillChar(pOptFldDesc^,sizeOf(FLDDesc),0);
    with pTableDesc^ do
    begin
      AnsiToNative(DBLocale,TableName,szTblName,255);
      StrPCopy(szTblType,TblProps.szTableType);
      bProtected := TblProps.bProtected;
      StrPCopy(pOptFldDesc^.szName,'LEVEL');
      pOptFldDesc^.iLen := length(ALevel)+1;
      pFldOptParams := pOptFldDesc;
      StrPCopy(szLevel,ALevel);
      pOptData := @szLevel;
      iOptParams := 1;
      hDB := DBHandle;
      Close;
      Check( DBIDoRestructure(hDB,        {DB handle}
                              1,          {no of tbls (has to be 1)}
                              pTableDesc, {table data desc.}
                              nil,        {pSaveAs}
                              nil,        {pKeyViol}
                              nil,        {pProblem}
                              False) );   {Analyze only}
    end;
  finally
    if pTableDesc <> nil then
      FreeMem(pTableDesc,sizeOf(CRTblDesc));
    if pOptFldDesc <> nil then
      FreeMem(pOptFldDesc,SizeOf(FLDDesc));
    Open;
    EnableControls;
  end;
end;

procedure TPx7Table.SetAutoSaveChanges(Value: boolean);
begin
  if (FAutoSaveChanges <> Value) then
    FAutoSaveChanges := Value;
end;

procedure TPx7Table.SetAutoChangeLevel(Value: boolean);
begin
  if (FAutoChangeLevel <> Value) then
    FAutoChangeLevel := Value;
end;

{-----------------}

procedure Register;
begin
  RegisterComponents('DBAddOns', [TPx7Table]);
end;

end.